Tech Arsenal 1/Tech Arsenal (Arsenal Computer).ISO/tek-02/nktools.zip/STRDEV.PAS

Pascal/Delphi Source File | 1991-02-11 | 8KB | 199 lines

unit StrDev;
(*===================================================================*\
|| UNIT NAME:    StrDev                                              ||
|| DEPENDENCIES: Dos.TPU                                             ||
|| PROGRAMMER:   Naoto Kimura                                        ||
|| LAST MOD ON:  9102.11                                             ||
||                                                                   ||
|| DESCRIPTION:  This is a text file device driver for printing to a ||
||               string.  The control for a text file is re-routed   ||
||               to send output to a string buffer instead of a file ||
||               or device.                                          ||
\*===================================================================*)
interface

uses dos;

var
    StrDevice : Text;

(*-------------------------------------------------------------------*\
| NAME: AssignStr                                                     |
|                                                                     |
|     This routine is used to associate a text file variable with a   |
| string output buffer.                                               |
\*-------------------------------------------------------------------*)
procedure AssignStr( var F    : Text );

(*-------------------------------------------------------------------*\
| NAME: GetStrBuf                                                     |
|                                                                     |
|      This routine returns the accumilated string output and clears  |
| the buffer.                                                         |
\*-------------------------------------------------------------------*)
function GetStrBuf( var F    : Text ) : String;

implementation

(*-------------------------------------------------------------------*\
| This record type defines the structure of the data stored in a file |
| variable type in the UserData field.  It contains information for   |
| the string buffer to which output is sent.                          |
\*-------------------------------------------------------------------*)
type
    StrDevRec    = record
        case Boolean of
        False:    ( Unused    : array [0..15] of byte );
        True:    ( StrBuf    : ^String )
        end;

{$F+}    (* force FAR reference *)

(*-------------------------------------------------------------------*\
| NAME: GetStrBuf                                                     |
|                                                                     |
|      This routine returns the accumilated string output and clears  |
| the buffer.                                                         |
\*-------------------------------------------------------------------*)
function GetStrBuf( var F    : Text ) : String;
    begin
    GetStrBuf := StrDevRec(TextRec(F).UserData).StrBuf^;
    StrDevRec(TextRec(F).UserData).StrBuf^ := ''
    end;    (* GetStrBuf *)

(*-------------------------------------------------------------------*\
| NAME:  StrOutput                                                    |
|                                                                     |
|     This is the output handling routine for files assigned to the   |
| string output device.   This is an internal service routine and     |
| will not be directly used by any procedure outside of this unit.    |
|                                                                     |
| EXTERNALS: type      TextRec (Dos), StrDevRec                       |
\*-------------------------------------------------------------------*)
{static far} function StrOutput(var f : TextRec) : integer;
    var
    p    : word;
    begin
    with f,StrDevRec(UserData) do begin
        p := 0;
        while p < BufPos do begin
        StrBuf^ := StrBuf^ + BufPtr^[p];
        Inc(p)
          end;
        BufPos := 0
      end;
    StrOutput := 0
    end;   (* StrOutput *)

(*-------------------------------------------------------------------*\
| NAME:  StrIgnore                                                    |
|                                                                     |
| This routine is used to perform a do-nothing function, usually for  |
| don't care conditions that may occur during I/O.  This is an        |
| internal service routine and will not be directly used by any       |
| procedure outside of this unit.                                     |
|                                                                     |
| EXTERNALS: type TextRec (Dos)                                       |
\*-------------------------------------------------------------------*)
{static far} function StrIgnore(var f : TextRec) : integer;
    begin
    StrIgnore := 0
    end;   (* StrIgnore *)

(*-------------------------------------------------------------------*\
| NAME:  StrClose                                                     |
|                                                                     |
| This routine is used to close an output stream to a string device.  |
| It is assumed that an AssignStr has been performed on the text file |
| variable to open it, and then Rewrite to actually open it.  This is |
| an internal service routine and will not be directly used by any    |
| procedure outside of this unit.                                     |
|                                                                     |
| EXTERNALS: type      TextRec (Dos)                                  |
\*-------------------------------------------------------------------*)
{static far} function StrClose(var f : TextRec) : integer;
    begin
    with f,StrDevRec(UserData) do begin
        Dispose(StrBuf)
      end;
    StrClose := 0
    end;   (* StrClose *)

(*-------------------------------------------------------------------*\
| NAME:  StrOpen                                                      |
|                                                                     |
| This routine is used to open an output stream to a string device.   |
| It is assumed that an AssignStr has been performed on the text file |
| variable.  This is an internal service routine and will not be      |
| directly used by any procedure outside of this unit.                |
|                                                                     |
| EXTERNALS: type      TextRec (Dos)                                  |
|            function  StrInput, StrOutput, StrIgnore                 |
\*-------------------------------------------------------------------*)
{static far} function StrOpen(var f : TextRec) : integer;
    const
    ErrMsg    : string
    = #13#10'StrDev unit: string device is write-only !'#13#10'$';
    var
    regs    : Registers;
    begin
    with f,StrDevRec(UserData) do begin
        BufPos := 0;
        BufEnd := 0;

        If Mode=fmInput then begin
        Regs.DS := Seg(ErrMsg[1]);
        Regs.DX := Ofs(ErrMsg[1]);
        Regs.AH := $09;
        Intr($21,Regs);
        Halt
          end
        else begin
        New(StrBuf);
        StrBuf^   := '';
        Mode      := fmOutput;
        InOutFunc := @StrOutput;
        FlushFunc := @StrOutput
          end;
        CloseFunc := @StrClose
      end;
    StrOpen := 0
    end;   (* StrOpen *)

(*-------------------------------------------------------------------*\
| NAME: AssignStrDev                                                  |
|                                                                     |
|      This routine returns the accumilated string output and clears  |
| the buffer.                                                         |
|                                                                     |
| EXTERNALS: const     fmClosed                                       |
|            function  StrOpen                                        |
\*-------------------------------------------------------------------*)
procedure AssignStr( var F    : Text );
    begin
    with TextRec(f) do begin
        Handle    := $FFFF;
        Mode    := fmClosed;
        BufSize    := sizeof(Buffer);
        BufPtr    := @Buffer;
        OpenFunc    := @StrOpen;
        Name[0] := #0
      end
    end;    (* AssignStr *)

var
    OldExitProc    : Pointer;

{static far} procedure Cleanup;
    begin
    ExitProc := OldExitProc;
    Close(StrDevice)
    end;    (* Cleanup *)

begin
    AssignStr( StrDevice );
    Rewrite(StrDevice);
    OldExitProc := ExitProc;
    ExitProc := @Cleanup
end.